{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-name-shadowing -Wno-star-is-type #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant bracket" #-}

{-
  Copyright 2020 The CodeWorld Authors. All rights reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}
module CodeWorld.EntryPoints where

import CodeWorld.Color
import CodeWorld.Driver
import CodeWorld.Event
import CodeWorld.Picture
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Prim
import GHC.StaticPtr
import GHC.Types
import Numeric (showFFloatAlt)
import System.IO
import System.IO.Unsafe
import System.Random

--------------------------------------------------------------------------------
-- Common code for activity, interaction, animation and simulation interfaces

-- | Runs an interactive CodeWorld program that responds to 'Event's.
-- Activities can interact with the user, change over time, and remember
-- information about the past.
--
-- Example: a program which draws a circle and changes its radius when user
-- presses Up or Down keys on her keyboard
--
-- @
--  &#x7b;-\# LANGUAGE OverloadedStrings \#-&#x7d;
-- import CodeWorld
--
-- main = activityOf initialRadius updateRadius circle
--    where
--      initialRadius = 1
--
--      updateRadius event radius =
--        case event of
--          KeyPress "Up"   -> radius + 1
--          KeyPress "Down" -> radius - 1
--          _               -> radius
-- @
activityOf ::
  -- | The initial state of the activity.
  world ->
  -- | The event handling function, which updates
  --   the state given an event.
  (Event -> world -> world) ->
  -- | The visualization function, which converts
  --   the state into a picture to display.
  (world -> Picture) ->
  IO ()
activityOf initial change picture = do
  hFlush stdout
  runInspect initial (const id) change picture picture

data Timeline a = Timeline
  { past :: [a], -- reversed list of past states
    present :: !a, -- present state
    future :: [a] -- list of future states
  }

newTimeline :: a -> Timeline a
newTimeline x = Timeline [] x []

applyToTimeline :: (a -> a) -> Timeline a -> Timeline a
applyToTimeline f timeline@(Timeline {..})
  | identical present new = timeline
  | otherwise = Timeline (present : past) new []
  where
    new = f present

undoTimeline :: Timeline a -> Timeline a
undoTimeline timeline@(Timeline {..}) = case past of
  [] -> timeline
  (x : xs) -> Timeline xs x (present : future)

redoTimeline :: Timeline a -> Timeline a
redoTimeline timeline@(Timeline {..}) = case future of
  [] -> timeline
  (x : xs) -> Timeline (present : past) x xs

restartTimeline :: Timeline a -> Timeline a
restartTimeline timeline@(Timeline {..}) = case reverse past of
  [] -> timeline
  x : xs -> Timeline [] x (xs ++ present : future)

timelineLength :: Timeline a -> Int
timelineLength (Timeline {..}) = length past + 1 + length future

travelToTime :: Double -> Timeline a -> Timeline a
travelToTime t timeline@(Timeline {..})
  | diff >= 0 = iterate redoTimeline timeline !! diff
  | otherwise = iterate undoTimeline timeline !! (- diff)
  where
    desiredPast = round (t * (fromIntegral (timelineLength timeline - 1)))
    actualPast = length past
    diff = desiredPast - actualPast

timelinePos :: Timeline a -> Double
timelinePos (Timeline {..})
  | null past && null future = 1
  | otherwise = fromIntegral (length past) / fromIntegral (length past + length future)

data Control :: * -> * where
  PlayButton :: Point -> Control a
  PauseButton :: Point -> Control a
  StepButton :: Point -> Control a
  RestartButton :: Point -> Control Double
  ZoomInButton :: Point -> Control a
  ZoomOutButton :: Point -> Control a
  PanningLayer :: Control a
  ResetViewButton :: Point -> Control a
  FastForwardButton :: Point -> Control a
  StartOverButton :: Point -> Control (Timeline a)
  BackButton :: Point -> Control Double
  TimeLabel :: Point -> Control Double
  SpeedSlider :: Point -> Control a
  ZoomSlider :: Point -> Control a
  UndoButton :: Point -> Control (Timeline a)
  RedoButton :: Point -> Control (Timeline a)
  HistorySlider :: Point -> Control (Timeline a)

data StrictPoint = SP !Double !Double deriving (Eq, Show)

data StrictMaybe a = SNothing | SJust !a deriving (Functor, Show)

data Wrapped a = Wrapped
  { state :: a,
    playbackSpeed :: !Double,
    lastInteractionTime :: !Double,
    zoomFactor :: !Double,
    panCenter :: !StrictPoint,
    panDraggingAnchor :: !(StrictMaybe StrictPoint),
    isDraggingSpeed :: !Bool,
    isDraggingHistory :: !Bool,
    isDraggingZoom :: !Bool
  }
  deriving (Show, Functor)

wrappedInitial :: a -> Wrapped a
wrappedInitial w =
  Wrapped
    { state = w,
      playbackSpeed = 1,
      lastInteractionTime = 1000,
      zoomFactor = 1,
      panCenter = SP 0 0,
      panDraggingAnchor = SNothing,
      isDraggingSpeed = False,
      isDraggingHistory = False,
      isDraggingZoom = False
    }

identical :: a -> a -> Bool
identical !x !y = isTrue# (reallyUnsafePtrEquality# x y)

toState :: (a -> a) -> (Wrapped a -> Wrapped a)
toState f w
  | identical s s' = w
  | otherwise = w {state = s'}
  where
    s = state w
    s' = f s

wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a
wrappedStep f dt w
  | playbackSpeed w == 0 = w
  | otherwise = toState (f (dt * playbackSpeed w)) w

wrappedEvent ::
  (Wrapped a -> [Control a]) ->
  (Double -> a -> a) ->
  (Event -> a -> a) ->
  Event ->
  Wrapped a ->
  Wrapped a
wrappedEvent ctrls stepHandler eventHandler event = markInteraction . handleChange
  where
    markInteraction w
      | TimePassing _ <- event, lastInteractionTime w > 5 = w
      | TimePassing dt <- event = w {lastInteractionTime = lastInteractionTime w + dt}
      | otherwise = w {lastInteractionTime = 0}
    handleChange w0
      | playbackSpeed w0 == 0 || handled = w1
      | otherwise = toState (eventHandler (adaptEvent event)) w1
      where
        (w1, handled) = foldr doCtrl (w0, False) (ctrls w0)
        doCtrl _ (w, True) = (w, True)
        doCtrl ctrl (w, False) = handleControl fullStep event ctrl w
        fullStep dt = stepHandler dt . eventHandler (TimePassing dt)
        adaptEvent (PointerMovement p) = PointerMovement (adaptPoint p)
        adaptEvent (PointerPress p) = PointerPress (adaptPoint p)
        adaptEvent (PointerRelease p) = PointerRelease (adaptPoint p)
        adaptEvent (TimePassing dt) = TimePassing (dt * playbackSpeed w0)
        adaptEvent other = other
        adaptPoint (x, y) = (x / k - dx, y / k - dy)
        SP dx dy = panCenter w1
        k = zoomFactor w1

scaleRange :: (Double, Double) -> (Double, Double) -> Double -> Double
scaleRange (a1, b1) (a2, b2) x = min b2 $ max a2 $ (x - a1) / (b1 - a1) * (b2 - a2) + a2

snapSlider :: Double -> [Double] -> Double -> Double
snapSlider eps targets val = foldr snap val targets
  where
    snap t v
      | abs (t - v) < eps = t
      | otherwise = v

xToPlaybackSpeed :: Double -> Double
xToPlaybackSpeed x = snapSlider 0.2 [1 .. 4] $ scaleRange (-1.4, 1.4) (0, 5) x

playbackSpeedToX :: Double -> Double
playbackSpeedToX = scaleRange (0, 5) (-1.4, 1.4)

zoomIncrement :: Double
zoomIncrement = 8 ** (1 / 10)

yToZoomFactor :: Double -> Double
yToZoomFactor y = zoomIncrement ** (scaleRange (-1.4, 1.4) (-10, 10) y)

zoomFactorToY :: Double -> Double
zoomFactorToY z = scaleRange (-10, 10) (-1.4, 1.4) (logBase zoomIncrement z)

handleControl ::
  (Double -> a -> a) -> Event -> Control a -> Wrapped a -> (Wrapped a, Bool)
handleControl _ (PointerPress (x, y)) (RestartButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = 0}, True)
handleControl _ (PointerPress (x, y)) (StartOverButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (restartTimeline <$> w, True)
handleControl _ (PointerPress (x, y)) (PlayButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 1}, True)
handleControl _ (PointerPress (x, y)) (PauseButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 0}, True)
handleControl _ (PointerPress (x, y)) (FastForwardButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = max 2 (playbackSpeed w + 1)}, True)
handleControl _ (PointerPress (x, y)) (ZoomInButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = zoomFactor w * zoomIncrement}, True)
handleControl _ (PointerPress (x, y)) (ZoomOutButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = zoomFactor w / zoomIncrement}, True)
handleControl _ (PointerPress (x, y)) (ResetViewButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = 1, panCenter = SP 0 0}, True)
handleControl _ (PointerPress (x, y)) (BackButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (max 0 . (subtract 0.1) <$> w, True)
handleControl _ (PointerPress (x, y)) (UndoButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (undoTimeline <$> w, True)
handleControl _ (PointerPress (x, y)) (RedoButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (redoTimeline <$> w, True)
handleControl f (PointerPress (x, y)) (StepButton (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = f 0.1 (state w)}, True)
handleControl _ (PointerPress (x, y)) (SpeedSlider (cx, cy)) w
  | abs (x - cx) < 1.5 && abs (y - cy) < 0.4 =
    (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = True}, True)
handleControl _ (PointerMovement (x, _)) (SpeedSlider (cx, _)) w
  | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx)}, True)
handleControl _ (PointerRelease (x, _)) (SpeedSlider (cx, _)) w
  | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = False}, True)
handleControl _ (PointerPress (x, y)) (ZoomSlider (cx, cy)) w
  | abs (x - cx) < 0.4 && abs (y - cy) < 1.5 =
    (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = True}, True)
handleControl _ (PointerMovement (_, y)) (ZoomSlider (_, cy)) w
  | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy)}, True)
handleControl _ (PointerRelease (_, y)) (ZoomSlider (_, cy)) w
  | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = False}, True)
handleControl _ (PointerPress (x, y)) (HistorySlider (cx, cy)) w
  | abs (x - cx) < 2.5 && abs (y - cy) < 0.4 =
    (travelToTime (1 / 2 + (x - cx) / 4.8) <$> w {isDraggingHistory = True}, True)
handleControl _ (PointerMovement (x, _)) (HistorySlider (cx, _)) w
  | isDraggingHistory w = (travelToTime (1 / 2 + (x - cx) / 4.8) <$> w, True)
handleControl _ (PointerRelease (x, _)) (HistorySlider (cx, _)) w
  | isDraggingHistory w = (travelToTime (1 / 2 + (x - cx) / 4.8) <$> w {isDraggingHistory = False}, True)
handleControl _ (PointerPress (x, y)) PanningLayer w =
  (w {panDraggingAnchor = SJust (SP x y)}, True)
handleControl _ (PointerMovement (x, y)) PanningLayer w
  | SJust (SP ax ay) <- panDraggingAnchor w,
    SP px py <- panCenter w =
    ( w
        { panCenter =
            SP
              (px + (x - ax) / zoomFactor w)
              (py + (y - ay) / zoomFactor w),
          panDraggingAnchor = SJust (SP x y)
        },
      True
    )
handleControl _ (PointerRelease _) PanningLayer w
  | SJust _ <- panDraggingAnchor w = (w {panDraggingAnchor = SNothing}, True)
handleControl _ _ _ w = (w, False)

wrappedDraw ::
  (Wrapped a -> [Control a]) -> (a -> Picture) -> Wrapped a -> Picture
wrappedDraw ctrls f w = drawControlPanel ctrls w <> dilated k (translated dx dy (f (state w)))
  where
    SP dx dy = panCenter w
    k = zoomFactor w

drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture
drawControlPanel ctrls w
  | alpha > 0 = pictures [drawControl w alpha c | c <- ctrls w]
  | otherwise = blank
  where
    alpha
      | lastInteractionTime w < 4.5 = 1
      | lastInteractionTime w < 5.0 = 10 - 2 * lastInteractionTime w
      | otherwise = 0

drawControl :: Wrapped a -> Double -> Control a -> Picture
drawControl _ alpha (RestartButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2
            <> translated 0.173 (-0.1) (solidRectangle 0.17 0.17)
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (StartOverButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2
            <> translated 0.173 (-0.1) (solidRectangle 0.17 0.17)
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (PlayButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        (solidPolygon [(-0.2, 0.25), (-0.2, -0.25), (0.2, 0)])
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (PauseButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated (-0.15) 0 (solidRectangle 0.2 0.6)
            <> translated 0.15 0 (solidRectangle 0.2 0.6)
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (FastForwardButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( solidPolygon [(-0.3, 0.25), (-0.3, -0.25), (-0.05, 0)]
            <> solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (ZoomInButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated
            (-0.05)
            (0.05)
            ( thickCircle 0.1 0.22
                <> solidRectangle 0.06 0.25
                <> solidRectangle 0.25 0.06
                <> rotated (- pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1))
            )
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (ZoomOutButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated
            (-0.05)
            (0.05)
            ( thickCircle 0.1 0.22
                <> solidRectangle 0.25 0.06
                <> rotated (- pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1))
            )
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ _ PanningLayer = blank
drawControl _ alpha (ResetViewButton (x, y)) = translated x y p
  where
    p =
      colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.7 0.2)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.2 0.7)
        <> colored (RGBA 0.0 0.0 0.0 alpha) (thickRectangle 0.1 0.5 0.5)
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (BackButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated 0.15 0 (solidRectangle 0.2 0.5)
            <> solidPolygon [(-0.05, 0.25), (-0.05, -0.25), (-0.3, 0)]
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (UndoButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated 0.15 0 (solidRectangle 0.2 0.5)
            <> solidPolygon [(-0.05, 0.25), (-0.05, -0.25), (-0.3, 0)]
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (StepButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated (-0.15) 0 (solidRectangle 0.2 0.5)
            <> solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha (RedoButton (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated (-0.15) 0 (solidRectangle 0.2 0.5)
            <> solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]
        )
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl w alpha (TimeLabel (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        (scaled 0.5 0.5 $ lettering (T.pack (showFFloatAlt (Just 4) (state w) "s")))
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 3.0 0.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8)
drawControl w alpha (SpeedSlider (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated xoff 0.75 $ scaled 0.5 0.5 $
            lettering (T.pack (showFFloatAlt (Just 2) (playbackSpeed w) "x"))
        )
        <> colored (RGBA 0 0 0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8))
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 2.8 0.25)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 2.8 0.25)
    xoff = playbackSpeedToX (playbackSpeed w)
drawControl w alpha (ZoomSlider (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated (-1.1) yoff $ scaled 0.5 0.5 $
            lettering (T.pack (show (round (zoomFactor w * 100) :: Int) ++ "%"))
        )
        <> colored (RGBA 0 0 0 alpha) (translated 0 yoff (solidRectangle 0.8 0.2))
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.25 2.8)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.25 2.8)
    yoff = zoomFactorToY (zoomFactor w)
drawControl w alpha (HistorySlider (x, y)) = translated x y p
  where
    p =
      colored
        (RGBA 0 0 0 alpha)
        ( translated xoff 0.75 $ scaled 0.5 0.5 $
            lettering (T.pack (show i ++ "/" ++ show n))
        )
        <> colored (RGBA 0.0 0.0 0.0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8))
        <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 4.8 0.25)
        <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 4.8 0.25)
    xoff = timelinePos (state w) * 4.8 - 2.4
    i = 1 + length (past (state w))
    n = timelineLength (state w)

drawingControls :: Wrapped () -> [Control ()]
drawingControls w
  | lastInteractionTime w > 5 = []
  | otherwise = commonControls ++ resetViewButton
  where
    commonControls =
      [ PanningLayer,
        ZoomInButton (9, -4),
        ZoomOutButton (9, -8),
        ZoomSlider (9, -6)
      ]
    resetViewButton
      | zoomFactor w /= 1 || panCenter w /= SP 0 0 = [ResetViewButton (9, -3)]
      | otherwise = []

-- | Draws a 'Picture'. This is the simplest CodeWorld entry point.
--
-- Example: a program which draws a circle of radius 1 in the middle of canvas
--
-- @
-- main = drawingOf $ circle 1
-- @
drawingOf ::
  -- | The picture to show on the screen.
  Picture ->
  IO ()
drawingOf pic = do
  hFlush stdout
  runInspect
    (wrappedInitial ())
    (wrappedStep step)
    (wrappedEvent drawingControls step event)
    (wrappedDraw drawingControls draw)
    (draw . state)
  where
    step _ _ = ()
    event _ _ = ()
    draw _ = pic

animationControls :: Wrapped Double -> [Control Double]
animationControls w
  | lastInteractionTime w > 5 = []
  | otherwise =
    commonControls ++ pauseDependentControls
      ++ backButton
      ++ resetViewButton
  where
    commonControls =
      [ PanningLayer,
        RestartButton (-9, -9),
        TimeLabel (8, -9),
        SpeedSlider (-3, -9),
        FastForwardButton (-1, -9),
        ZoomInButton (9, -4),
        ZoomOutButton (9, -8),
        ZoomSlider (9, -6)
      ]
    pauseDependentControls
      | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-6, -9)]
      | otherwise = [PauseButton (-8, -9)]
    backButton
      | playbackSpeed w == 0 && state w > 0 = [BackButton (-7, -9)]
      | otherwise = []
    resetViewButton
      | zoomFactor w /= 1 || panCenter w /= SP 0 0 = [ResetViewButton (9, -3)]
      | otherwise = []

-- | Shows an animation, with a picture for each time given by the parameter.
--
-- Example: a program showing a square which rotates once every two seconds
--
-- @
-- main = animationOf rotatingSquare
--
-- rotatingSquare :: Double -> Picture
-- rotatingSquare seconds = rotated angle square
--   where
--     square = rectangle 2 2
--     angle = pi * seconds
-- @
animationOf ::
  -- | A function that produces animation
  --   frames, given the time in seconds.
  (Double -> Picture) ->
  IO ()
animationOf f = do
  hFlush stdout
  runInspect
    (wrappedInitial 0)
    (wrappedStep (+))
    (wrappedEvent animationControls (+) (const id))
    (wrappedDraw animationControls f)
    (f . state)

simulationControls :: Wrapped w -> [Control w]
simulationControls w
  | lastInteractionTime w > 5 = []
  | otherwise = commonControls ++ pauseDependentControls ++ resetViewButton
  where
    commonControls =
      [ PanningLayer,
        FastForwardButton (-4, -9),
        SpeedSlider (-6, -9),
        ZoomInButton (9, -4),
        ZoomOutButton (9, -8),
        ZoomSlider (9, -6)
      ]
    pauseDependentControls
      | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-2, -9)]
      | otherwise = [PauseButton (-8, -9)]
    resetViewButton
      | zoomFactor w /= 1 || panCenter w /= SP 0 0 = [ResetViewButton (9, -3)]
      | otherwise = []

statefulDebugControls :: Wrapped (Timeline w) -> [Control (Timeline w)]
statefulDebugControls w
  | lastInteractionTime w > 5 = []
  | otherwise =
    panningLayer ++ pauseDependentControls ++ commonControls
      ++ resetViewButton
  where
    hasHistory = not (null (past (state w)))
    hasFuture = not (null (future (state w)))
    advance
      | hasFuture = [RedoButton (6, -9)]
      | otherwise = [StepButton (6, -9)]
    regress
      | hasHistory = [UndoButton (0, -9)]
      | otherwise = []
    commonControls =
      [ StartOverButton (-1, -9),
        FastForwardButton (-4, -9),
        SpeedSlider (-6, -9),
        ZoomInButton (9, -4),
        ZoomOutButton (9, -8),
        ZoomSlider (9, -6)
      ]
    pauseDependentControls
      | playbackSpeed w == 0 =
        [PlayButton (-8, -9), HistorySlider (3, -9)] ++ advance ++ regress
      | otherwise = [PauseButton (-8, -9)]
    resetViewButton
      | zoomFactor w /= 1 || panCenter w /= SP 0 0 = [ResetViewButton (9, -3)]
      | otherwise = []
    panningLayer
      | playbackSpeed w == 0 = [PanningLayer]
      | otherwise = []

-- | A version of 'activityOf' which runs an interactive CodeWorld program
-- in debugging mode.  In this mode, the program gets controls to pause and
-- manipulate time, and even go back in time to look at past states.
debugActivityOf ::
  -- | The initial state of the interaction.
  world ->
  -- | The event handling function, which updates
  --   the state given an event.
  (Event -> world -> world) ->
  -- | The visualization function, which converts
  --   the state into a picture to display.
  (world -> Picture) ->
  IO ()
debugActivityOf initial change picture = do
  hFlush stdout
  runInspect
    (wrappedInitial (newTimeline initial))
    (wrappedStep (const id))
    (wrappedEvent statefulDebugControls (const id) (applyToTimeline . change))
    (wrappedDraw statefulDebugControls (picture . present))
    (picture . present . state)

-- | Runs an interactive multi-user CodeWorld program that is joined by several
-- participants over the internet.
--
-- Example: a skeleton of a game for two players
--
-- @
-- &#x7b;-\# LANGUAGE StaticPointers, OverloadedStrings \#-&#x7d;
-- import CodeWorld
--
-- main = groupActivityOf 2 init step view
--   where
--     init = static (\\gen -> {- initialize state of the game world, possibly using random number generator -})
--     step = static (\\playerNumber event world -> {- modify world based on event occuring for given player -})
--     view = static (\\playerNumber world -> {- generate a picture that will be shown to given player in the given state of the world-})
-- @
groupActivityOf ::
  -- | The number of participants to expect.  The participants will be
  -- numbered starting at 0.
  Int ->
  -- | The function to create initial state of the activity. 'System.Random.StdGen' parameter can be used to generate random numbers.
  StaticPtr (StdGen -> world) ->
  -- | The event handling function, which updates the state given a
  --   participant number and user interface event.
  StaticPtr (Int -> Event -> world -> world) ->
  -- | The visualization function, which converts a participant number
  --   and the state into a picture to display.
  StaticPtr (Int -> world -> Picture) ->
  IO ()
groupActivityOf numPlayers initial event draw = do
  hFlush stdout
  dhash <- getDeployHash
  let token =
        SteplessToken
          { tokenDeployHash = dhash,
            tokenNumPlayers = numPlayers,
            tokenInitial = staticKey initial,
            tokenEvent = staticKey event,
            tokenDraw = staticKey draw
          }
  runGame
    token
    numPlayers
    (deRefStaticPtr initial)
    (const id)
    (deRefStaticPtr event)
    (deRefStaticPtr draw)

-- | A version of 'groupActivityOf' that avoids static pointers, and does not
-- check for consistency.
unsafeGroupActivityOf ::
  -- | The number of participants to expect.  The participants will be
  -- numbered starting at 0.
  Int ->
  -- | The initial state of the activity.
  (StdGen -> world) ->
  -- | The event handling function, which updates the state given a
  --   participant number and user interface event.
  (Int -> Event -> world -> world) ->
  -- | The visualization function, which converts a participant number
  --   and the state into a picture to display.
  (Int -> world -> Picture) ->
  IO ()
unsafeGroupActivityOf numPlayers initial event draw = do
  hFlush stdout
  dhash <- getDeployHash
  let token = PartialToken dhash
  runGame token numPlayers initial (const id) event draw

-- | Prints a debug message to the CodeWorld console when a value is forced.
-- This is equivalent to the similarly named function in `Debug.Trace`, except
-- that it sets appropriate buffering to use the CodeWorld console.
trace :: Text -> a -> a
trace msg x = unsafePerformIO $ do
  oldMode <- hGetBuffering stderr
  hSetBuffering stderr (BlockBuffering Nothing)
  hPutStrLn stderr (T.unpack msg)
  hFlush stderr
  hSetBuffering stderr oldMode
  return x
